home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 1372.ZIP / PIBCAT.ARC / PIBCATD.PAS < prev    next >
Pascal/Delphi Source File  |  1988-10-29  |  21KB  |  499 lines
  1. (*----------------------------------------------------------------------*)
  2. (*         Display_DWC_Contents --- Display contents of DWC file        *)
  3. (*----------------------------------------------------------------------*)
  4.  
  5. PROCEDURE Display_DWC_Contents( DWCFileName : AnyStr );
  6.  
  7. (*----------------------------------------------------------------------*)
  8. (*                                                                      *)
  9. (*    Procedure: Display_DWC_Contents                                   *)
  10. (*                                                                      *)
  11. (*    Purpose:   Displays contents of a DWC file                        *)
  12. (*                                                                      *)
  13. (*    Calling sequence:                                                 *)
  14. (*                                                                      *)
  15. (*       Display_DWC_Contents( DWCFileName : AnyStr );                  *)
  16. (*                                                                      *)
  17. (*          DWCFileName --- name of DWC file whose contents are to be   *)
  18. (*                          listed.                                     *)
  19. (*                                                                      *)
  20. (*    Calls:                                                            *)
  21. (*                                                                      *)
  22. (*       Aside from internal subroutines, these routines are required:  *)
  23. (*                                                                      *)
  24. (*          Get_Unix_Date     --- convert Unix date to string           *)
  25. (*          Open_File         --- open a file                           *)
  26. (*          Close_File        --- close a file                          *)
  27. (*          Entry_Matches     --- Perform wildcard match                *)
  28. (*          Display_Page_Titles                                         *)
  29. (*                            --- Display titles at top of page         *)
  30. (*          DUPL              --- Duplicate a character into a string   *)
  31. (*                                                                      *)
  32. (*----------------------------------------------------------------------*)
  33.  
  34. (*----------------------------------------------------------------------*)
  35. (*                  Map of DWC file entry header                        *)
  36. (*----------------------------------------------------------------------*)
  37.  
  38. CONST
  39.    Max_Entries = 1800              (* Maximum # of files in DWC file *);
  40.  
  41. TYPE
  42.    FNameType = ARRAY[1..13] OF CHAR;
  43.    ID_Type   = ARRAY[1..3 ] OF CHAR;
  44.  
  45.                                    (* Header for entire DWC file *)
  46.    DWC_Header_Type = RECORD
  47.                         Size    : WORD       (* Size of archive structure, future expansion *);
  48.                         Ent_SZ  : BYTE       (* Size of directory entry, future expansion   *);
  49.                         Header  : FNameType  (* Name of Header file to print on listings    *);
  50.                         Time    : LONGINT    (* Time stamp of last modification to archive  *);
  51.                         Entries : LONGINT    (* Number of entries in archive                *);
  52.                         ID_3    : ID_Type    (* The string "DWC" to identify archive        *);
  53.                      END;
  54.                                    (* Individual file entry *)
  55.    DWC_Entry_Type  = RECORD
  56.                         Filename : FNameType (* File and extension       *);
  57.                         Size     : LONGINT   (* Original size            *);
  58.                         Time     : LONGINT   (* Packed date and time     *);
  59.                         New_Size : LONGINT   (* Compressed size          *);
  60.                         FPos     : LONGINT   (* Position in DWC file     *);
  61.                         Method   : BYTE      (* Compression method       *);
  62.                         SZ_C     : BYTE      (* Size of comment          *);
  63.                         SZ_D     : BYTE      (* Size of dir name on add  *);
  64.                         CRC      : WORD      (* Cyclic Redundancy Check  *);
  65.                      END;
  66.                                    (* Entire DWC directory *)
  67.  
  68.    DWC_Dir_Type    = ARRAY[1..Max_Entries] OF DWC_Entry_Type;
  69.    DWC_Dir_Ptr     = ^DWC_Dir_Type;
  70.  
  71. (* STRUCTURED *) CONST
  72.    DWC_ID : ID_Type = 'DWC';
  73.  
  74. VAR
  75.    DWCFile       : FILE            (* DWC file to be read             *);
  76.    DWC_Entry     : DWC_Entry_Type  (* Entry for one file in DWC lib   *);
  77.    DWC_Header    : DWC_Header_Type (* Main header for DWC file        *);
  78.    DWC_Pos       : LONGINT         (* Current byte offset in DWC file *);
  79.    Bytes_Read    : INTEGER         (* # bytes read from DWC file file *);
  80.    Ierr          : INTEGER         (* Error flag                      *);
  81.    Do_Blank_Line : BOOLEAN         (* TRUE to print blank line        *);
  82.    Entry_To_Get  : INTEGER         (* Current entry being worked on   *);
  83.    Dir_In_Memory : BOOLEAN         (* TRUE if entire dir fits in RAM  *);
  84.    Dir_Ptr       : DWC_Dir_Ptr     (* Points to RAM-resident DWC dir  *);
  85.    Dir_Size      : WORD            (* Size in bytes of directory      *);
  86.  
  87. (*----------------------------------------------------------------------*)
  88. (*        Get_DWC_Header --- Get initial header entry in DWC file       *)
  89. (*----------------------------------------------------------------------*)
  90.  
  91. FUNCTION Get_DWC_Header( VAR Error : INTEGER ) : BOOLEAN;
  92.  
  93. (*----------------------------------------------------------------------*)
  94. (*                                                                      *)
  95. (*    Function:  Get_DWC_Header                                         *)
  96. (*                                                                      *)
  97. (*    Purpose:   Gets initial DWC header                                *)
  98. (*                                                                      *)
  99. (*    Calling sequence:                                                 *)
  100. (*                                                                      *)
  101. (*       OK := Get_DWC_Header( VAR Error : INTEGER ) : BOOLEAN;         *)
  102. (*                                                                      *)
  103. (*          Error    --- Error flag                                     *)
  104. (*          OK       --- TRUE if header successfully found, else FALSE  *)
  105. (*                                                                      *)
  106. (*----------------------------------------------------------------------*)
  107.  
  108. CONST
  109.    BufSize = 256;
  110.  
  111. VAR
  112.    I        : INTEGER;
  113.    J        : INTEGER;
  114.    Buf      : ARRAY[1..BufSize] OF CHAR;
  115.    L        : LONGINT;
  116.    ID_Found : BOOLEAN;
  117.    ID_Ptr   : ^ID_Type;
  118.  
  119. BEGIN (* Get_DWC_Header *)
  120.                                    (* Assume no error to start *)
  121.    Error := 0;
  122.                                    (* Assume no space to hold entire  *)
  123.                                    (* directory in memory.            *)
  124.    Dir_In_Memory := FALSE;
  125.    Dir_Ptr       := NIL;
  126.                                    (* Try to find ID = 'DWC' near end *)
  127.                                    (* of file.  We will look up to 10 *)
  128.                                    (* 256 byte blocks away from end   *)
  129.                                    (* for this info.                  *)
  130.  
  131.    L        := FileSize( DWCFile );
  132.    I        := 1;
  133.    ID_Found := FALSE;
  134.  
  135.    REPEAT
  136.                                    (* Position to next potential block *)
  137.  
  138.       DWC_Pos := L - ( I * BufSize - PRED( I ) * 5 );
  139.  
  140.       IF ( DWC_Pos < 0 ) THEN
  141.          DWC_Pos := 0;
  142.  
  143.       SEEK( DWCFile , DWC_Pos );
  144.                                    (* Read in a block of information *)
  145.       IF ( IOResult = 0 ) THEN
  146.          BEGIN
  147.  
  148.             BlockRead( DWCFile, Buf, BufSize, Bytes_Read );
  149.  
  150.             IF ( IOResult = 0 ) THEN
  151.                BEGIN
  152.                                    (* See if we can find "DWC" here  *)
  153.  
  154.                   J := Bytes_Read - 2;
  155.  
  156.                   WHILE ( ( J > 0 ) AND ( NOT ID_Found ) ) DO
  157.                      BEGIN
  158.  
  159.                         ID_Ptr := @Buf[ J ];
  160.  
  161.                         IF ( ID_Ptr^ = DWC_ID ) THEN
  162.                            ID_Found := TRUE
  163.                         ELSE
  164.                            DEC( J );
  165.  
  166.                      END;
  167.                                    (* In case we need to try next block *)
  168.                   INC( I );
  169.  
  170.                END
  171.             ELSE
  172.                Error := Format_Error;
  173.  
  174.          END
  175.       ELSE
  176.          Error := Format_Error;
  177.  
  178.    UNTIL ( ( I > 10 ) OR ID_Found OR ( Error <> 0 ) );
  179.  
  180.                                    (* If we didn't find DWC, quit.         *)
  181.    IF ( NOT ID_Found ) THEN
  182.       Error := Format_Error
  183.    ELSE
  184.       BEGIN                        (* We found DWC.                       *)
  185.                                    (* True end of DWC file (we hope).     *)
  186.  
  187.          DWC_Pos := DWC_Pos + J + 2;
  188.  
  189.          SEEK( DWCFile , DWC_Pos - SIZEOF( DWC_Header ) );
  190.  
  191.          BlockRead( DWCFile, DWC_Header, SIZEOF( DWC_Header ), Bytes_Read );
  192.  
  193.                                    (* Check # of entries for reasonableness *)
  194.  
  195.          IF ( ( DWC_Header.Entries < 0 ) OR ( DWC_Header.Entries > Max_Entries ) ) THEN
  196.             Error := Format_Error
  197.          ELSE
  198.             BEGIN
  199.                                    (* # entries looked OK.  Pick up offset *)
  200.                                    (* of first directory entry.            *)
  201.  
  202.                WITH DWC_Header DO
  203.                   BEGIN
  204.                      Dir_Size := Entries * Ent_SZ;
  205.                      DWC_Pos  := DWC_Pos - ( Dir_Size + Size );
  206.                   END;
  207.  
  208.                SEEK( DWCFile , DWC_Pos );
  209.  
  210.                IF ( IOResult <> 0 ) THEN
  211.                   Error := Format_Error;
  212.  
  213.                                    (* See if we can read entire directory *)
  214.                                    (* into memory.  If so, do that now.   *)
  215.  
  216.                IF ( MaxAvail > Dir_Size ) THEN
  217.                   BEGIN
  218.  
  219.                      GETMEM( Dir_Ptr , Dir_Size );
  220.  
  221.                      IF ( Dir_Ptr <> NIL ) THEN
  222.                         BEGIN
  223.  
  224.                            Dir_In_Memory := TRUE;
  225.  
  226.                            BlockRead( DWCFile, Dir_Ptr^, Dir_Size, Bytes_Read );
  227.  
  228.                            IF ( ( IOResult <> 0 ) OR
  229.                               ( Bytes_Read < Dir_Size ) ) THEN
  230.                               Error := Format_Error;
  231.  
  232.                         END;
  233.  
  234.                   END;
  235.  
  236.             END;
  237.  
  238.       END;
  239.                                     (* Report success/failure to calling *)
  240.                                     (* routine.                          *)
  241.  
  242.    Get_DWC_Header := ( Error = 0 );
  243.  
  244. END   (* Get_DWC_Header *);
  245.  
  246. (*----------------------------------------------------------------------*)
  247. (*     Get_Next_DWC_Entry --- Get next header entry in DWC file         *)
  248. (*----------------------------------------------------------------------*)
  249.  
  250. FUNCTION Get_Next_DWC_Entry( VAR DWCEntry : DWC_Entry_Type;
  251.                                  Entry_No : INTEGER;
  252.                              VAR Error    : INTEGER  ) : BOOLEAN;
  253.  
  254. (*----------------------------------------------------------------------*)
  255. (*                                                                      *)
  256. (*    Function:  Get_Next_DWC_Entry                                     *)
  257. (*                                                                      *)
  258. (*    Purpose:   Gets header information for next file in DWC file      *)
  259. (*                                                                      *)
  260. (*    Calling sequence:                                                 *)
  261. (*                                                                      *)
  262. (*       OK := Get_Next_DWC_Entry( VAR DWCEntry : DWC_Entry_Type;       *)
  263. (*                                     Entry_No : INTEGER;              *)
  264. (*                                 VAR Error    : INTEGER ) : BOOLEAN;  *)
  265. (*                                                                      *)
  266. (*          DWCEntry --- Header data for next file in DWC file          *)
  267. (*          Error    --- Error flag                                     *)
  268. (*          Entry_No --- Entry number to get (if resident dir)          *)
  269. (*          OK       --- TRUE if header successfully found, else FALSE  *)
  270. (*                                                                      *)
  271. (*----------------------------------------------------------------------*)
  272.  
  273. BEGIN (* Get_Next_DWC_Entry *)
  274.                                    (* Assume no error to start       *)
  275.    Error := 0;
  276.                                    (* Read in the file header entry. *)
  277.  
  278.    IF Dir_In_Memory THEN
  279.       DWC_Entry := Dir_Ptr^[ Entry_No ]
  280.    ELSE
  281.       BEGIN
  282.  
  283.          BlockRead( DWCFile, DWC_Entry, SIZEOF( DWC_Entry ), Bytes_Read );
  284.  
  285.                                    (* If wrong size read, or header marker *)
  286.                                    (* byte is incorrect, report DWC file   *)
  287.                                    (* format error.                        *)
  288.  
  289.          IF ( ( IOResult <> 0 ) OR ( Bytes_Read < SIZEOF( DWC_Entry ) ) ) THEN
  290.             Error := Format_Error;
  291.  
  292.       END;
  293.                                     (* Report success/failure to calling *)
  294.                                     (* routine.                          *)
  295.  
  296.    Get_Next_DWC_Entry := ( Error = 0 );
  297.  
  298. END   (* Get_Next_DWC_Entry *);
  299.  
  300. (*----------------------------------------------------------------------*)
  301. (*        Display_DWC_Entry --- Display DWC file file entry info        *)
  302. (*----------------------------------------------------------------------*)
  303.  
  304. PROCEDURE Display_DWC_Entry( DWC_Entry : DWC_Entry_Type );
  305.  
  306. VAR
  307.    SDate     : STRING[10];
  308.    STime     : STRING[12];
  309.    I         : INTEGER;
  310.    FName     : AnyStr;
  311.    TimeDate  : LONGINT;
  312.    DTRec     : DateTime;                                 
  313.  
  314. BEGIN (* Display_DWC_Entry *)
  315.  
  316.    WITH DWC_Entry DO
  317.       BEGIN
  318.                                    (* Pick up file name *)
  319.  
  320.          FName := COPY( FileName, 1, PRED( POS( #0 , FileName ) ) );
  321.  
  322.                                    (* See if this file matches the   *)
  323.                                    (* entry spec wildcard.  Exit if  *)
  324.                                    (* not.                           *)
  325.  
  326.          IF Use_Entry_Spec THEN
  327.             IF ( NOT Entry_Matches( FName ) ) THEN
  328.                EXIT;
  329.                                    (* Make sure room on current page *)
  330.                                    (* for this entry name.           *)
  331.                                    (* If enough room, print blank    *)
  332.                                    (* line if requested.  This will  *)
  333.                                    (* only happen for first file.    *)
  334.          IF Do_Blank_Line THEN
  335.             BEGIN
  336.                IF ( Lines_Left < 2 ) THEN
  337.                   Display_Page_Titles
  338.                ELSE
  339.                   BEGIN
  340.                      WRITELN( Output_File );
  341.                      DEC( Lines_left );
  342.                   END;
  343.                Do_Blank_Line := FALSE;
  344.             END
  345.          ELSE
  346.             IF ( Lines_Left < 1 ) THEN
  347.                Display_Page_Titles;
  348.  
  349.                                    (* Add '. ' to front if we're     *)
  350.                                    (* expanding ARCs in main listing *)
  351.          IF Expand_Libs_In THEN
  352.             FName := '. ' + FName;
  353.  
  354.                                    (* Get date and time of creation *)
  355.  
  356.          Get_Unix_Style_Date( Time, DTRec.Year, DTRec.Month, DTRec.Day, 
  357.                                     DTRec.Hour, DTRec.Min, DTRec.Sec );
  358.  
  359.          PackTime( DTRec , TimeDate );
  360.          
  361.          Dir_Convert_Date_And_Time( TimeDate , SDate , STime );
  362.  
  363.                                    (* Write out file name, length, date, time *)
  364.  
  365.          WRITE( Output_File , Left_Margin_String, '      ' , FName );
  366.  
  367.          FOR I := LENGTH( FName ) TO 14 DO
  368.             WRITE( Output_File , ' ' );
  369.  
  370.          WRITE  ( Output_File , Size:8, '  ' );
  371.          WRITE  ( Output_File , SDate, '  ' );
  372.          WRITE  ( Output_File , STime );
  373.          WRITELN( Output_File );
  374.  
  375.                                    (* Count lines left on page *)
  376.          IF Do_Printer_Format THEN
  377.             DEC( Lines_Left );
  378.  
  379.                                    (* Increment total entry count *)
  380.          INC( Total_Entries );
  381.  
  382.                                    (* Increment total space used  *)
  383.  
  384.          Total_ESpace := Total_ESpace + Size;
  385.  
  386.       END;
  387.  
  388. END (* Display_DWC_Entry *);
  389.  
  390. (*----------------------------------------------------------------------*)
  391.  
  392. BEGIN (* Display_DWC_Contents *)
  393.  
  394.                                    (* Set left margin spacing *)
  395.  
  396.    Left_Margin_String := Left_Margin_String + DUPL( ' ' , Library_Indent );
  397.  
  398.                                    (* Set file title *)
  399.  
  400.    File_Title := Left_Margin_String + ' DWC file: ' + DWCFileName;
  401.  
  402.                                    (* Display DWC file file's name *)
  403.    IF Do_Printer_Format THEN
  404.       IF ( Lines_Left < 3 ) THEN
  405.          Display_Page_Titles;
  406.                                    (* If we're listing contents at end  *)
  407.                                    (* of directory, print DWC file name. *)
  408.                                    (* Do_Blank_Line flags whether we    *)
  409.                                    (* need to print blank line in entry *)
  410.                                    (* lister subroutine.  If listing    *)
  411.                                    (* inline, then it's true for the    *)
  412.                                    (* first file; otherwise it's false. *)
  413.                                    (* This is to prevent unnecessary    *)
  414.                                    (* blank lines in output listing     *)
  415.                                    (* when no files are selected from   *)
  416.                                    (* a given DWC file.                  *)
  417.    IF ( NOT Expand_Libs_In ) THEN
  418.       BEGIN
  419.          WRITELN( Output_File ) ;
  420.          WRITE  ( Output_File , File_Title );
  421.          DEC( Lines_Left , 2 );
  422.          Do_Blank_Line := FALSE;
  423.       END
  424.    ELSE
  425.       Do_Blank_Line := TRUE;
  426.                                    (* Try opening DWC file file for processing *)
  427.  
  428.    Open_File( DWCFileName , DWCFile, DWC_Pos, Ierr );
  429.  
  430.                                    (* Issue error message if open fails *)
  431.    IF ( Ierr <> 0 ) THEN
  432.       BEGIN
  433.          WRITELN( Output_File ,
  434.                   DUPL( ' ' , MAX( 0 , MIN( 12 , 13 - LENGTH( DWCFileName ) ) ) ),
  435.                   '     Can''t open DWC file ',DWCFileName );
  436.          IF Do_Printer_Format THEN
  437.             BEGIN
  438.                DEC( Lines_Left );
  439.                IF ( Lines_Left < 1 ) THEN
  440.                   Display_Page_Titles;
  441.             END;
  442.          EXIT;
  443.       END
  444.    ELSE IF ( NOT Expand_Libs_In ) THEN
  445.       BEGIN
  446.  
  447.          WRITELN( Output_File );
  448.          WRITELN( Output_File );
  449.                                    (* Count lines left on page *)
  450.          IF Do_Printer_Format THEN
  451.             DEC( Lines_Left );
  452.  
  453.       END;
  454.                                    (* Loop over entries in DWC file file *)
  455.  
  456.    IF Get_DWC_Header( Ierr ) THEN
  457.       BEGIN
  458.                                    (* Entry to get *)
  459.          Entry_To_Get := 1;
  460.                                    (* Loop over entries      *)
  461.  
  462.          WHILE ( ( Entry_To_Get <= DWC_Header.Entries ) AND
  463.                  ( Get_Next_DWC_Entry( DWC_Entry , Entry_To_Get , Ierr ) ) ) DO
  464.             BEGIN
  465.                Display_DWC_Entry( DWC_Entry );
  466.                INC( Entry_To_Get );
  467.             END;
  468.  
  469.       END
  470.    ELSE
  471.       WRITELN( Output_File , 'Failed to get DWC header' );
  472.  
  473.                                    (* Print blank line after last entry   *)
  474.                                    (* in DWC file, if we're expanding      *)
  475.                                    (* DWC files right after listing them,  *)
  476.                                    (* but only if DWC file had any entries *)
  477.                                    (* listed.                             *)
  478.  
  479.    IF ( Expand_Libs_In AND ( NOT Do_Blank_Line ) ) THEN
  480.       BEGIN
  481.          WRITELN( Output_File );
  482.          IF Do_Printer_Format THEN
  483.             DEC( Lines_Left );
  484.       END;
  485.                                    (* Dispose of RAM-resident directory *)
  486.    IF ( Dir_Ptr <> NIL ) THEN
  487.       FREEMEM( Dir_Ptr , Dir_Size );
  488.  
  489.                                    (* Close DWC file file *)
  490.    Close_File( DWCFile );
  491.                                    (* Restore previous left margin spacing *)
  492.  
  493.    Left_Margin_String := DUPL( ' ' , Left_Margin );
  494.  
  495.                                    (* No file title *)
  496.    File_Title := '';
  497.  
  498. END   (* Display_DWC_Contents *);
  499.